home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / v_dispatch.t < prev    next >
Text File  |  1988-02-12  |  11KB  |  324 lines
  1. (herald vax_dispatch (env tsys))
  2.  
  3. (define (dispatch-init)
  4.   (lap (handle-stype handle-true handle-fixnum handle-pair
  5.         handle-char handle-nonvalue *handlers* icall-wrong-nargs
  6.         bogus-return bogus-return-miss apply handle-immediate
  7.     handle-magic-frame no-default-method)
  8.  
  9.     (movl p (d@r nil-reg slink/dispatch))
  10.     (moval (label dispatch) (d@r nil-reg slink/dispatch-label))
  11.     (mnegl ($ 1) nargs)
  12.     (movl (@r sp) tp)
  13.     (jmp (@r tp))))
  14.  
  15.  
  16. (lap-template (0 0 -1 nil stack handle-dispatch-return)
  17. dispatch-return                  
  18.     (cmpl AN nil-reg)                             ; did we get a method?
  19.     (j= default)
  20.     (movl A1 P)
  21.     (movl (d@r P -2) TP)
  22.     (movl (d@r SP 16) A1)                    ; self is first arg of method
  23. op-icall
  24.     (cmpb NARGS (d@r AN template/nargs))         ; check number of args
  25.     (j= %icall-ok)
  26.     (j< %icall-wrong-nargs)
  27.     (cmpb ($ (fx+ header/template 128)) (d@r AN -2))        ; check nary bit
  28.     (jn= %icall-wrong-nargs)
  29. %icall-ok
  30.     (jmp (@r AN))
  31. %icall-wrong-nargs
  32.   (movl a1 (d@r TASK task/t0))
  33.   (movl a2 (d@r TASK (fx+ task/t0 4)))
  34.   (movl a3 (d@r TASK (fx+ task/t0 8)))
  35.   (movl a4 (d@r TASK (fx+ task/t0 12)))
  36.   (clrl s0)
  37.   (jsb (*d@r nil-reg slink/nary-setup))
  38.   (movl an a2)
  39.   (movl (d@r SP 8) a1)   ; operation
  40.   (addl2 ($ 20) SP)
  41.   (movl (d@r nil-reg slink/dispatch) P)
  42.   (movl (d@r P (static 'icall-wrong-nargs)) P)
  43.   (movl (d@r p 2) p)
  44.   (movl (d@r P -2) TP)
  45.   (jmp  (@r TP))
  46. default
  47.     (movl (d@r SP 16) A1)                         ; self is first arg of method
  48.     (movl (d@r P offset/operation-default) P)
  49.     (cmpl p nil-reg)
  50.     (j= no-default)
  51.     (addl2 ($ 20) SP)
  52.     (jmp (*d@r nil-reg slink/icall))
  53. no-default    
  54.   (movl a1 (d@r TASK task/t0))
  55.   (movl a2 (d@r TASK (fx+ task/t0 4)))
  56.   (movl a3 (d@r TASK (fx+ task/t0 8)))
  57.   (movl a4 (d@r TASK (fx+ task/t0 12)))
  58.   (clrl s0)
  59.   (jsb (*d@r nil-reg slink/nary-setup))
  60.   (movl an a2)
  61.   (movl (d@r SP 8) a1)   ; operation
  62.   (addl2 ($ 20) SP)
  63.   (movl (d@r nil-reg slink/dispatch) P)
  64.   (movl (d@r P (static 'no-default-method)) P)
  65.   (movl (d@r p 2) p)
  66.   (movl (d@r P -2) TP)
  67.   (jmp  (@r TP))
  68. handle-dispatch-return    
  69.     (movl nil-reg AN)
  70.     (rsb))
  71.  
  72.                               
  73.     
  74. (define *structure-template*
  75.   (lap-template (0 0 0 nil heap structure-handler)
  76.     (jmp (*d@r nil-reg slink/undefined-effect))
  77. structure-handler
  78.     (movl (d@r A1 -2) A1)                       ; internal-template
  79.     (movl (d@r A1 -30) A1)                        ; stype-handler
  80.     (jmp (label dispatch))))
  81.     
  82. (define *stype-template*
  83.   (lap-template (9 0 0 nil heap stype-handler)           ; stype size is 9
  84.     (jmp (*d@r nil-reg slink/undefined-effect))
  85. stype-handler
  86.     (movl (d@r nil-reg slink/dispatch) AN)
  87.     (movl (d@r AN (static 'handle-stype)) A1)
  88.     (movl (d@r a1 2) a1)
  89.     (jmp (label dispatch))))
  90.   
  91. (define *traced-op-template*
  92.   (lap-template (0 0 0 nil stack t-op)
  93.     (pushl A1)                                       ; self
  94.     (pushl nil-reg)
  95.     (pushl P)                                        ; op
  96.     (pushl A1)                                       ; obj
  97.     (pushl ($ (fx+ (fixnum-ashl 4 16) header/vframe)))
  98.     (pushal (label traced-op-return))
  99.     (jmp (label dispatch))
  100. t-op))
  101.     
  102. (lap-template (0 0 -1 nil stack handle-traced-op-return)
  103. traced-op-return                  
  104.     (cmpl AN nil-reg)                         ; did we get a method?
  105.     (j= traced-op-default)                      ; AN contains code
  106.     (movl A1 P)                              ; environment
  107.     (movl (d@r P -2) TP)
  108.     (movl (d@r SP 16) A1)                         ; self is first arg of method
  109.     (jmp (label op-icall))
  110. traced-op-default
  111.     (movl (d@r P 6) P)                       ; rhs is operation
  112.     (jmp (label default))
  113. handle-traced-op-return    
  114.     (movl nil-reg AN)
  115.     (rsb))
  116.   
  117.  
  118. ;;; We have the operation in P, the object in A1 and we can use AN which is
  119. ;;; where the method id returned
  120.  
  121. (define *operation-template*
  122.   (lap-template (3 0 1 t heap operation-handler)
  123.     (pushl A1)                                   ; self
  124.     (pushl nil-reg)
  125.     (pushl P)                                    ; op
  126.     (pushl A1)                                   ; obj
  127.     (pushal ($ (fx+ (fixnum-ashl 4 16) header/vframe)))
  128.     (pushal (label dispatch-return))
  129. dispatch
  130.     (bicb3 ($ #b11111100) A1 S0)                 ; get object tag 
  131.     (cmpb S0 ($ tag/extend))                     ; is it an extend?
  132.     (jn= object-not-extend)
  133.     (movl (d@r A1 -2) TP)                        ; get object's header
  134.     (bicb3 ($ #b11111100) TP S0)                 ; is it a template?
  135.     (cmpb S0 ($ tag/extend))
  136.     (jn= object-not-closure)
  137.     (cmpw (@r TP) ($ VAX-JUMP-ABSOLUTE))         ; closure internal template?
  138.     (j= cit)
  139.     (cvtwl (d@r TP -8) S0)                       ; get handler offset
  140.     (j= no-handler)                       ; it it's 0, no handler
  141.     (jmp (index (@r TP) S0))                     ; call the handler         
  142. no-handler              
  143.     (movl nil-reg AN)
  144.     (rsb)
  145. cit
  146.     (movl (d@r TP 2) AN)                         ; get auxilliary template
  147.     (cvtwl (d@r AN -8) S0)                       ; get handler offset
  148.     (j= no-handler)
  149.     (jmp (index (@r AN) S0))
  150. object-not-extend
  151.     (movl (d@r nil-reg slink/dispatch) AN)         ; establish addressability
  152.     (cmpb S0 ($ tag/fixnum))
  153.     (j= fixnum)
  154.     (cmpb S0 ($ tag/pair))
  155.     (j= pair)
  156.     (cmpb A1 ($ header/char))
  157.     (j= char)
  158.     (cmpb A1 ($ header/true))
  159.     (j= true)
  160.     (cmpb A1 ($ header/nonvalue))
  161.     (j= nonvalue)
  162.     (movl (d@r AN (static 'handle-immediate)) A1)
  163.     (movl (d@r a1 2) a1)
  164.     (jmp (label dispatch))
  165. true
  166.     (movl (d@r AN (static 'handle-true)) A1)
  167.     (movl (d@r a1 2) a1)
  168.     (jmp (label dispatch))
  169. nonvalue
  170.     (movl (d@r AN (static 'handle-nonvalue)) A1)
  171.     (movl (d@r a1 2) a1)
  172.     (jmp (label dispatch))
  173. fixnum   
  174.     (movl (d@r AN (static 'handle-fixnum)) A1)
  175.     (movl (d@r a1 2) a1)
  176.     (jmp (label dispatch))
  177. pair
  178.     (movl (d@r AN (static 'handle-pair)) A1)
  179.     (movl (d@r a1 2) a1)
  180.     (jmp (label dispatch))
  181. char
  182.     (movl (d@r AN (static 'handle-char)) A1)
  183.     (movl (d@r a1 2) a1)
  184.     (jmp (label dispatch))
  185. object-not-closure
  186.     (movl (d@r nil-reg slink/dispatch) AN)
  187.     (movl (d@r AN (static '*handlers*)) AN)
  188.     (movl (d@r an 2) an)
  189.     (ashl ($ -2) TP S0)                          ; get header field
  190.     (bicl3 ($ #xFFFFFFE0) S0 S0)                 ; isolate low five bits
  191.     (movl (index (d@r AN 2) S0) A1)              ; index into vector of handlers
  192.     (jmp (label dispatch))
  193. operation-handler
  194.   (movl (d@r A1 offset/operation-handler) A1)
  195.     (jmp (label dispatch))))
  196.  
  197. ;;; At the top of the join loop the stack looks like    self                       
  198. ;;;                                                     next
  199. ;;;                                                     op
  200. ;;;                                                     obj
  201. ;;;                                                     *state-template*
  202. ;;;                                               sp -> dispatch-return-template
  203.  
  204. (define *join-template*
  205.   (lap-template (2 0 1 t heap join-handler)
  206. join-template
  207.     (movl (d@r P 2) P)                     ; joined lhs
  208.     (jmp (*d@r nil-reg slink/icall))                       
  209. join-handler                                            
  210.     (movl (d@r A1 6) (d@r SP 16))          ; next <- rhs
  211.     (movl (d@r A1 2) A1)                   ; get joined lhs
  212.     (movl A1 (d@r SP 8))                   ; obj  <- lhs
  213.     (pushal (label join-return))
  214.     (jmp (label dispatch))))               ; try to get a handler from lhs
  215.  
  216. (lap-template (0 0 -1 t stack join-return-handler)
  217. join-return
  218.     (cmpl AN nil-reg)                      ; did we get a handler?
  219.     (j= join-miss)
  220.     (rsb)
  221. join-miss
  222.     (movl (d@r SP 16) A1)                  ; get next
  223.     (movl A1 (d@r SP 8))                   ; obj <- next
  224.     (movl (d@r nil-reg slink/dispatch) AN)                    
  225.     (movl nil-reg (d@r SP 16)) ; next <- tbsh
  226.     (jmp (label dispatch))                 ; try rhs
  227. join-return-handler
  228.     (movl nil-reg AN)
  229.     (rsb))
  230.  
  231. (define *bogus-entity-template*
  232.   (lap-template (2 0 1 t heap bogus-entity-handler)
  233.     (movl (d@r P 2) P)
  234.     (jmp (*d@r nil-reg slink/icall))
  235. bogus-entity-handler
  236.     (movl nargs s2)
  237.     (movl A2 (d@r TASK 4))
  238.     (movl A3 (d@r TASK 8))
  239.     (movl A4 (d@r TASK 12))
  240.     (movl ($ 1) S0)
  241.     (jsb (*d@r nil-reg slink/nary-setup))
  242.     (movl (d@r A1 6) A2)               ; bogus-entity handler
  243.     (movl P A1)                        ; operation is argument to handler
  244.     (movl A2 P)
  245.     (pushl s2)
  246.     (pushl AN)
  247.     (pushal (label bogus-return))
  248.     (movl ($ 2) NARGS)
  249.     (jmp (*d@r nil-reg slink/icall))))
  250.  
  251. (lap-template (2 0 -1 nil stack bogus-return-handler)
  252. bogus-return
  253.     (cmpl A1 nil-reg)
  254.     (jn= bogus-return-hit)
  255.     (movl (d@r nil-reg slink/dispatch) AN)
  256.     (movl (d@r SP 4) A3)               ; args
  257.     (movl A1 A2)                       ; method
  258.     (movl (d@r AN (static 'bogus-return-miss)) A1)
  259.     (movl (d@r a1 2) a1)
  260.     (movl (d@r AN (static 'apply)) P)
  261.     (movl (d@r p 2) p)
  262.     (addl2 ($ 12) SP)    ; pop off bogus return continuation
  263.     (movl ($ 4) NARGS)
  264.     (movl (d@r P -2) TP)
  265.     (jmp (@r TP))
  266. bogus-return-hit
  267.     (movl (d@r nil-reg slink/dispatch) AN)
  268.     (movl (d@r SP 4) a4)               ; args
  269.     (movl A1 A2)                       ; method
  270.     (movl (d@r AN (static 'bogus-return)) A1)
  271.     (movl (d@r a1 2) a1)
  272.     (movl (d@r AN (static 'apply)) P)
  273.     (movl (d@r p 2) p)
  274.     (movl ($ 5) NARGS)      ; dummy obj in a3
  275.     (movl (d@r P -2) TP)
  276.     (jmp (@r TP))
  277. bogus-return-handler
  278.     (movl nil-reg AN)
  279.     (rsb))
  280.  
  281. (define (bogus-return-miss method  . args)
  282.   (lap ()
  283.     (movl nil-reg AN)                  ; compiled handlers return register
  284.     (moval (label join-return) A1)
  285.     (cmpl (@r SP) A1)
  286.     (j= joined-bogus-return-miss)
  287.     (movl (d@r SP 12) P)                ; restore operation
  288.     (rsb)
  289. joined-bogus-return-miss
  290.     (movl (d@r SP 16) P)                ; restore operation
  291.     (addl2 ($ 4) SP)                      ; pop return addr
  292.     (jmp (label join-miss))))
  293.  
  294.  
  295. (define (bogus-return method obj . args)
  296.   (lap ()
  297.     (movl (d@r SP 8) NARGS)            ; restore nargs and pop continuation
  298.     (incl NARGS)                  ; add one for obj
  299.     (addl2 ($ 12) SP)
  300.     (movl A1 P)                        ; method in procedure register
  301.     (moval (label join-return) A1)          ; is a join return address on top?
  302.     (cmpl (@r SP) A1)
  303.     (jn= bogus-dispatch-return)
  304. joined-bogus-return
  305.     (addl2 ($ 4) SP)                      ; pop join return addr
  306. bogus-dispatch-return
  307.     (movl (d@r SP 20) A1)              ; self is first of interpreted method
  308.     (movl (d@r SP 8)  A2)              ; obj is second of interpreted method
  309.     (addl2 ($ 24) SP)                    ; dispatch return + vframe 
  310.     (jmp (*d@r nil-reg slink/icall))))
  311.  
  312.  
  313. (define *magic-frame-template*
  314.  (lap-template (4 0 -1 t stack magic-frame-handler)
  315.   (moval (d@r SP 20) SP)
  316.   (movl (@r sp) tp)
  317.   (jmp (@r tp))
  318. magic-frame-handler
  319.   (movl (d@r nil-reg slink/kernel) AN)
  320.   (movl (d@r AN (static 'handle-magic-frame)) A1)
  321.   (movl (d@r a1 2) a1)
  322.   (jmp (label dispatch))))
  323.  
  324. (dispatch-init)